'          *** 3D-Tortengrafik 1.4 ***  © 1990 by Michael Gottwald

 DIM Norm%(1),Netz%(1),Schraffur1%(15),Schraffur2%(15),Punkte%(3)
 DIM Punkte2%(3),Punkte3%(3),Punkte4%(3),Punkte5%(3),Streifen%(1)
 DIM Balken%(1),Netz2%(3):Norm%(0)=&Hffff:Norm%(1)=&Hffff
 Netz%(0)=&Haaaa:Netz%(1)=&H5555:FOR i%=0 TO 15:READ d%:Schraffur1%(i%)=d%
 Schraffur2%(15-i%)=d%:NEXT:Punkte%(0)=&H9248:Punkte%(2)=&H4924
 Punkte2%(1)=&H9248:Punkte3%(0)=&H8208:Punkte3%(3)=&H1041
 Punkte4%(0)=&H8010:Punkte4%(3)=&H801:Punkte5%(1)=&H800:Punkte5%(2)=8
 Streifen%(0)=&Haaaa:Streifen%(1)=&Haaaa:Balken%(0)=&Hffff
 Netz2%(0)=&Haaaa:Netz2%(2)=&H5555
 
 x=150:y=74:c=3:c2=2:a=2
 t$="MedRes 1         640x242 ,  6 Farben + 4 Muster":Text
 y=94:t$="MedRes 2         640x242 , 14 Farben + 4 Muster":Text
 y=114:t$="Hires 1          640x498 ,  6 Farben + 4 Muster":Text
 y=134:t$="Hires 2          640x498 , 14 Farben + 4 Muster":Text
 y=154:t$="Monochrom 1      640x242 ,  1 Farbe + 12 Muster":Text
 y=174:t$="Monochrom 2      640x498 ,  1 Farbe + 12 Muster":Text
 FOR y%=63 TO 163 STEP 20:LINE (100,y%)-(100,y%+16),1:LINE -(140,y%+16),2
 LINE -(140,y%),2:LINE -(100,y%),1:NEXT:LOCATE 28,2:COLOR 2,0
 PRINT "Monochrom 1/2 ist für eine Hardcopy mit einem S/W-Drucker ";
 PRINT "am sinnvollsten !"

Gadgets: CALL Maus (x,y):IF x<100 OR  x>140 THEN Gadgets
           IF y>62  AND y<79  THEN Hoehe=242:Tiefe=3:Modus=2:q=30:GOTO Haupt
           IF y>82  AND y<99  THEN Hoehe=242:Tiefe=4:Modus=2:q=70:GOTO Haupt
           IF y>102 AND y<119 THEN Hoehe=498:Tiefe=3:Modus=4:q=30:GOTO Haupt
           IF y>122 AND y<139 THEN Hoehe=498:Tiefe=4:Modus=4:q=70:GOTO Haupt
           IF y>142 AND y<159 THEN Hoehe=242:Tiefe=3:Modus=2:q=12:GOTO Haupt
           IF y>162 AND y<179 THEN Hoehe=498:Tiefe=3:Modus=4:q=12:GOTO Haupt
         GOTO Gadgets                
 
Haupt: SCREEN 1,640,Hoehe+14,Tiefe,Modus
 w$=SPACE$(26)+"© 199O by Michael Gottwald":WINDOW 1,w$,(0,0)-(630,Hoehe),4,1
 WINDOW 1
 PALETTE 0,0,0.6,0.7:PALETTE 1,0,0,0:PALETTE 2,0.8,0.8,0:PALETTE 3,0,1,0
 PALETTE 4,1,0,0:PALETTE 5,0,0,1:PALETTE 6,1,0,1:PALETTE 7,1,1,1
 DIM p(70),w$(70),c(70,5)
Start: COLOR ,0:CLS:LOCATE 2,30:a=2:x=252:y=12:c=2:c2=0:t$="3D-Tortengrafik"
 CALL Text:LOCATE 6,3:COLOR 1,0:LINE (244,4)-(244,16),7
 LINE -(380,16),1:LINE -(380,4),1:LINE -(244,4),7:x=16:y=60:c=3
 LINE (240,2)-(240,18),7:LINE -(384,18),1:LINE -(384,2),1:LINE -(240,2),7
 t$="Dieses Programm erzeugt eine dreidimensionale Tortengrafik.":CALL Text
 y=y+10:t$="Es kann bis zu 70 verschiedene Segmente einer Scheibe nach"
 t$=t$+" prozentualer":CALL Text:y=y+10:t$="Einteilung zeichnen.":CALL Text
 y=y+50:x=176:a=1:c=4:t$="© 199O written by Michael Gottwald"
 CALL Text:LINE (128,120)-(128,136),1:LINE -(496,136),7:LINE -(496,120),7
 LINE -(128,120),1:y=y+50:x=196:c=5
 t$="...Linke Maustaste drücken...":CALL Text:WHILE MOUSE(0)=0:WEND
Frage: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0:s=0:pi=5.30795e-315
 t$="(P)rozentwerte oder (B)eliebige Zahlen ? ":Text
 INPUT f$:f$=UCASE$(f$):IF f$="P" THEN Prozente
                        IF f$="B" THEN Beliebig
 GOTO Frage
Beliebig: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2:z=0  
 t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
 t$=" 0 = Ende !":LOCATE 8:COLOR 3
BelZahl: GOSUB Eingabe:z=z+1:IF z>q THEN PRINT"Zuviel Zahlen !":GOTO Beliebig
         s=s+x:p(z)=x:IF x<>0 THEN BelZahl
         z=z-1:PRINT:INPUT "Was soll hinter einer Zahl stehen ";k$:GOTO Torte
Prozente: LINE (0,18)-(630,200),0,bf:c=2:x=8:y=30:a=2
 t$="Bitte die Zahlen eingeben.- Maximal"+STR$(q)+" !":CALL Text:y=y+10
 t$="Die Summe aller darf 100 natürlich nicht überschreiten !":CALL Text
 y=y+10:t$="0 = Ende !":CALL Text:LOCATE 8:COLOR 3
ProzZahl: GOSUB Eingabe:IF x+s=100 THEN s=s+x:p(z)=x:z=z+1:k$="%":GOTO Torte
        IF x=0 OR s+x>100 OR x>100 THEN ProzZahl
       s=s+x:p(z)=x:z=z+1:IF z<q THEN ProzZahl    
Eingabe: PRINT " Zahl Nr."z+1;":  (Summe bisher:"s;:IF f$="P" THEN PRINT"%";
         PRINT ")";
Wort:   INPUT " ";x:COLOR 5:INPUT "Text dazu (max. 10 Zeichen): ",w$(z)
        IF LEN(w$(z))>10 THEN Wort :ELSE COLOR 3:RETURN

Torte: IF q=12 THEN
         SCREEN 1,640,256,1,Modus:WINDOW 1,w$,(0,0)-(630,Hoehe),4,1      
         WINDOW 1:PALETTE 0,1,1,1:PALETTE 1,0,0,0
       END IF  
  CLS:z=z-1:CIRCLE (320,120),200,1,pi,2*pi,0.2:LINE (120,100)-(120,120),1
  LINE (520,100)-(520,120),1:CIRCLE (320,100),200,1,,,0.2
  sw=0:c=1:PATTERN &Hffff,Norm%:FOR i=0 TO z
  IF q=12 THEN
   c=1:ON i GOTO M1,M2,M3,M4,M5,M6,M7,M8,M9,M10,M11,12
  END IF 
  IF q=30 THEN IF (i+1)/7=INT((i+1)/7) THEN c=1:Nr=(i+1)/7:GOTO Muster
  IF q=70 THEN IF (i+1)/15=INT((i+1)/15) THEN c=1:Nr=(i+1)/15:GOTO Muster
  GOTO Seg
Muster: ON Nr GOTO M1,M4,M5,M6
Seg: GOSUB Segment:c=c+1:NEXT:PATTERN &H71ce
   a=2:FOR i=0 TO z:c=7:LINE (c(i,0),c(i,1))-(c(i,2),c(i,3)),1
   y=c(i,3):IF y>c(i,1) THEN y=y-5
   t$=w$(i):IF c(i,2)<c(i,0) THEN                              
              x=(c(i,2)-(LEN(w$(i))*8))
              IF q=12 THEN CALL MText :ELSE CALL Text
              GOTO Ok
            END IF  
   x=c(i,2):IF q=12 THEN CALL MText :ELSE CALL Text
Ok: y=y+10:x=x-8:IF c(i,2)<c(i,0) THEN x=x+8-LEN(k$)*8
    c=2:t$=STR$(p(i))+k$:IF q=12 THEN CALL MText :ELSE CALL Text
   NEXT:PATTERN &Hffff,Norm%:GOTO Gadget
               
Segment:
  IF f$="B" THEN p=(p(i)/s)*100 :ELSE p=p(i)
  w=sw+(360*p/100):ew=w*pi/180:fs=sw:sw=sw*pi/180:z1=320+SIN(sw)*200
   z2=100+COS(sw)*40:z3=320+SIN(ew)*200:z4=100+COS(ew)*40
    LINE (320,100)-(z1,z2),1:LINE (320,100)-(z3,z4),1 
     M=(ew-sw)/2:M=ew-M:PAINT (320+SIN(M)*198,100+COS(M)*38),c,1
      f=0:ff=0:IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN f=1
      IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN ff=1
      IF f=1 OR ff=1 THEN GOSUB Front
     a=sw+0.5*(ew-sw):sw=w
     c(i,0)=320+SIN(a)*180:c(i,1)=100+COS(a)*30
     c(i,2)=320+SIN(a)*235:c(i,3)=100+COS(a)*80
     IF a>1.56 AND a<4.72 THEN c(i,3)=100+COS(a)*60
  RETURN           
Front: IF w>=0 AND w<=89 OR w>270 AND w<=360 THEN LINE (z3,z4)-(z3,z4+20),1
    IF fs>=0 AND fs<=89 OR fs>270 AND fs<=360 THEN LINE (z1,z2)-(z1,z2+20),1
    IF f=1 THEN GOSUB Sangle   
    IF ff=1 THEN GOSUB Eangle
  RETURN
Sangle: PAINT (z1+1,z2+1),c,1:RETURN
Eangle: PAINT (z3-1,z4+1),c,1:RETURN  

Gadget: c1=7:c2=1:ct1=3:ct2=4:IF q=12 THEN c1=1
        x=28:y=14:a=1:c=ct2:t$="Ende":IF q=12 THEN CALL MText :ELSE CALL Text
        LINE (20,4)-(20,20),c1:LINE -(68,20),c2:LINE -(68,4),1
        LINE -(20,4),c1:y=34:x=16:c=ct1:t$="Nochmal":LINE (8,24)-(8,40),c1
        IF q=12 THEN CALL MText :ELSE CALL Text
        LINE -(79,40),c2:LINE -(79,24),c2:LINE -(8,24),c1
check: CALL Maus (x,y):IF x>19 AND x<69 AND y>3 AND y<21 THEN LOCATE 10:END       
       IF x>7 AND x<80 AND y>23 AND y<41 AND q=12 THEN RUN
       IF x>7 AND x<80 AND y>23 AND y<41 THEN Start
      GOTO check

SUB Text STATIC
 SHARED x,y,c,c2,a,t$           ' a ist der x-Abstand des Schattens
 POKEW WINDOW(8)+38,y+1:COLOR c2,0:PRINT PTAB(x+a);t$:POKE WINDOW(8)+28,0
 POKEW WINDOW(8)+38,y:COLOR c:PRINT PTAB(x);t$:POKE WINDOW(8)+28,1
END SUB

SUB Maus (x,y) STATIC
 WHILE MOUSE(0)=0:WEND:x=MOUSE(3):y=MOUSE(4):WHILE MOUSE(0)<>0:WEND
END SUB 

SUB MText STATIC                ' Füür Monochrom-Modus...
 SHARED x,y,t$
 POKEW WINDOW(8)+38,y:COLOR 1:PRINT PTAB(x);t$
END SUB   
                   'Schraffur 1:
     DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492    
     DATA &H9249,&H4924,&H2492,&H9249,&H4924,&H2492
     DATA &H9249,&H4924,&H2492,&H9249
M1:  PATTERN ,Netz%:GOTO Seg
M2:  PATTERN ,Streifen%:GOTO Seg
M3:  PATTERN ,Balken%:GOTO Seg
M4:  PATTERN ,Schraffur1%:GOTO Seg
M5:  PATTERN ,Schraffur2%:GOTO Seg
M6:  PATTERN ,Netz2%:GOTO Seg
M7:  PATTERN ,Punkte%:GOTO Seg
M8:  PATTERN ,Punkte2%:GOTO Seg
M9:  PATTERN ,Punkte3%:GOTO Seg
M10: PATTERN ,Punkte4%:GOTO Seg
M11: PATTERN ,Punkte5%:GOTO Seg